;;; cider-stacktrace.el --- Stacktrace navigator -*- lexical-binding: t -*-

;; Copyright © 2014 Jeff Valk

;; Author: Jeff Valk <jv@jeffvalk.com>

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.

;; This file is not part of GNU Emacs.

;;; Commentary:

;; Stacktrace filtering and stack frame source navigation

;;; Code:

(require 'button)
(require 'dash)

;; Variables

(defgroup cider-stacktrace nil
  "Stacktrace filtering and navigation."
  :prefix "cider-stacktrace-"
  :group 'cider)

(defcustom cider-stacktrace-default-filters '(tooling dup)
  "Frame types to omit from initial stacktrace display."
  :type 'list
  :group 'cider-stacktrace)


;; Faces

(defface cider-stacktrace-error-class-face
  '((t (:inherit font-lock-warning-face)))
  "Face for exception class names"
  :group 'cider-stacktrace)

(defface cider-stacktrace-filter-shown-face
  '((t (:inherit button :underline t)))
  "Face for filter buttons representing frames currently visible"
  :group 'cider-stacktrace)

(defface cider-stacktrace-filter-hidden-face
  '((t (:inherit button :underline nil)))
  "Face for filter buttons representing frames currently filtered out"
  :group 'cider-stacktrace)

(defface cider-stacktrace-face
  '((t (:inherit default)))
  "Face for stack frame text"
  :group 'cider-stacktrace)

(defface cider-stacktrace-ns-face
  '((t (:inherit font-lock-comment-face)))
  "Face for stack frame namespace name"
  :group 'cider-stacktrace)

(defface cider-stacktrace-fn-face
  '((t (:inherit cider-stacktrace-face :weight bold)))
  "Face for stack frame function name"
  :group 'cider-stacktrace)


;; Mode & key bindings

(defvar cider-stacktrace-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map "j" 'cider-stacktrace-toggle-java)
    (define-key map "c" 'cider-stacktrace-toggle-clj)
    (define-key map "r" 'cider-stacktrace-toggle-repl)
    (define-key map "t" 'cider-stacktrace-toggle-tooling)
    (define-key map "d" 'cider-stacktrace-toggle-duplicates)
    (define-key map "a" 'cider-stacktrace-show-all)
    map))

(define-minor-mode cider-stacktrace-mode
  "CIDER Stacktrace Buffer Mode."
  nil
  (" CIDER Stacktrace")
  cider-stacktrace-mode-map
  (setq buffer-read-only t)
  (setq-local truncate-lines t)
  (setq-local cider-stacktrace-hidden-frame-count 0)
  (setq-local cider-stacktrace-filters cider-stacktrace-default-filters))


;; Stacktrace filtering

(defun cider-stacktrace-indicate-filters (filters)
  "Update enabled state of filter buttons. Find buttons with a 'filter property;
if filter is a member of FILTERS, or if filter is nil ('show all') and the
argument list is non-nil, fontify the button as disabled. Upon finding text with
a 'hidden-count property, stop searching and update the hidden count text."
  (with-current-buffer (get-buffer cider-error-buffer)
    (save-excursion
      (goto-char (point-min))
      (let ((inhibit-read-only t)
            (get-face (lambda (hide)
                        (if hide
                            'cider-stacktrace-filter-hidden-face
                          'cider-stacktrace-filter-shown-face))))
        ;; Toggle buttons
        (while (not (or (get-text-property (point) 'hidden-count) (eobp)))
          (let ((button (button-at (point))))
            (when button
              (let* ((filter (button-get button 'filter))
                     (face (funcall get-face (if filter
                                                 (member filter filters)
                                               filters))))
                (button-put button 'face face)))
            (goto-char (or (next-property-change (point))
                           (point-max)))))
        ;; Update hidden count
        (when (and (get-text-property (point) 'hidden-count)
                   (re-search-forward "[0-9]+" (line-end-position) t))
          (replace-match
           (number-to-string cider-stacktrace-hidden-frame-count)))))))

(defun cider-stacktrace-apply-filters (filters)
  "Set visibility on stack frames using FILTERS.
Update `cider-stacktrace-hidden-frame-count' and indicate filters applied."
  (with-current-buffer (get-buffer cider-error-buffer)
    (save-excursion
      (goto-char (point-min))
      (let ((inhibit-read-only t)
            (hidden 0))
        (while (not (eobp))
          (let* ((flags (get-text-property (point) 'flags))
                 (hide (if (-intersection filters flags) t nil)))
            (when hide (setq hidden (+ 1 hidden)))
            (put-text-property (point) (line-beginning-position 2) 'invisible hide))
          (forward-line 1))
        (setq cider-stacktrace-hidden-frame-count hidden)))
    (cider-stacktrace-indicate-filters filters)))


;; Interactive functions

(defun cider-stacktrace-show-all ()
  "Reset `cider-stacktrace-filters', and apply filters."
  (interactive)
  (cider-stacktrace-apply-filters
   (setq cider-stacktrace-filters nil)))

(defun cider-stacktrace-toggle (flag)
  "Update `cider-stacktrace-filters' to add or remove FLAG, and apply filters."
  (cider-stacktrace-apply-filters
   (setq cider-stacktrace-filters
         (if (memq flag cider-stacktrace-filters)
             (remq flag cider-stacktrace-filters)
           (cons flag cider-stacktrace-filters)))))

(defun cider-stacktrace-toggle-java ()
  "Toggle display of Java stack frames."
  (interactive)
  (cider-stacktrace-toggle 'java))

(defun cider-stacktrace-toggle-clj ()
  "Toggle display of Clojure stack frames."
  (interactive)
  (cider-stacktrace-toggle 'clj))

(defun cider-stacktrace-toggle-repl ()
  "Toggle display of REPL stack frames."
  (interactive)
  (cider-stacktrace-toggle 'repl))

(defun cider-stacktrace-toggle-tooling ()
  "Toggle display of Tooling stack frames (compiler, nREPL middleware, etc)."
  (interactive)
  (cider-stacktrace-toggle 'tooling))

(defun cider-stacktrace-toggle-duplicates ()
  "Toggle display of stack frames that are duplicates of their descendents."
  (interactive)
  (cider-stacktrace-toggle 'dup))


;; Text button functions

(defun cider-stacktrace-filter (button)
  "Apply filter(s) indicated by the BUTTON."
  (with-temp-message "Filters may also be toggled with the keyboard."
    (let ((flag (button-get button 'filter)))
      (if flag
          (cider-stacktrace-toggle flag)
        (cider-stacktrace-show-all)))
    (sit-for 5)))

(defun cider-stacktrace-navigate (button)
  "Navigate to the stack frame represented by the BUTTON."
  (let ((var (button-get button 'var))
        (line (button-get button 'line)))
    (condition-case nil
        (let* ((info (cider-var-info var))
               (file (cadr (assoc "file" info))))
          (cider-jump-to-def-for (vector file file line)))
      (error "No source info"))))


;; Rendering

(defun cider-stacktrace-render-cause (buffer cause note)
  "Emit into BUFFER the CAUSE exception class, message, and data, and NOTE."
  (with-current-buffer buffer
    (nrepl-dbind-response cause (class message data)
      (put-text-property 0 (length class)
                         'font-lock-face
                         'cider-stacktrace-error-class-face
                         class)
      (insert note " " class " " message)
      (newline)
      (when data
        (insert (cider-font-lock-as-clojure data))
        (newline)))))

(defun cider-stacktrace-render-filters (buffer filters)
  "Emit into BUFFER toggle buttons for each of the FILTERS."
  (with-current-buffer buffer
    (insert "  Show: ")
    (dolist (filter filters)
      (insert-text-button (first filter)
                          'filter (second filter)
                          'follow-link t
                          'action 'cider-stacktrace-filter
                          'help-echo (format "Toggle %s stack frames"
                                             (first filter)))
      (insert " "))
    (let ((hidden "(0 frames hidden)"))
      (put-text-property 0 (length hidden) 'hidden-count t hidden)
      (insert " " hidden))
    (newline)))

(defun cider-stacktrace-render-frame (buffer frame)
  "Emit into BUFFER function call site info for the stack FRAME.
This associates text properties to enable filtering and source navigation."
  (with-current-buffer buffer
    (nrepl-dbind-response frame (file line flags class method name var ns fn)
      (let ((flags (mapcar 'intern flags))) ; strings -> symbols
        (insert-text-button (format "%30s:%5d  %s/%s"
                                    (if (member 'repl flags) "REPL" file) line
                                    (if (member 'clj flags) ns class)
                                    (if (member 'clj flags) fn method))
                            'name name 'var var 'line line 'flags flags
                            'follow-link t
                            'action 'cider-stacktrace-navigate
                            'help-echo "View source at this location"
                            'face 'cider-stacktrace-face)
        (save-excursion
          (let ((p3 (point))
                (p1 (search-backward " "))
                (p2 (search-forward "/")))
            (put-text-property p1 p2 'face 'cider-stacktrace-ns-face)
            (put-text-property p2 p3 'face 'cider-stacktrace-fn-face)))
        (newline)))))

(defun cider-stacktrace-render (buffer causes frames)
  "Emit into BUFFER useful stacktrace information for the CAUSES and FRAMES."
  (with-current-buffer buffer
    (let ((inhibit-read-only t))
      ;; Exceptions
      (cider-stacktrace-render-cause buffer (first causes) "Unhandled")
      (dolist (cause (rest causes))
        (cider-stacktrace-render-cause buffer cause "Caused by"))
      (newline)
      ;; Stacktrace filters
      (cider-stacktrace-render-filters
       buffer
       `(("Clojure" clj) ("Java" java) ("REPL" repl)
         ("Tooling" tooling) ("Duplicates" dup) ("All" ,nil)))
      (newline)
      ;; Stacktrace frames
      (dolist (frame frames)
        (cider-stacktrace-render-frame buffer frame)))
    ;; Set mode, apply filters, move point to first stacktrace frame.
    (cider-stacktrace-mode 1)
    (cider-stacktrace-apply-filters cider-stacktrace-filters)
    (goto-char (next-single-property-change (point-min) 'flags))
    (font-lock-refresh-defaults)))

(provide 'cider-stacktrace)

;;; cider-stacktrace.el ends here
